home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue52 / HTML / Code / AppServer / UHTTPApp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-01  |  3.3 KB  |  131 lines
  1. unit UHTTPApp;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   HTTPApp;
  8.  
  9. type
  10.   TUSScriptingBlockEvent = procedure (Sender: TObject; Body: string; var ReplaceText: string) of object;
  11.  
  12.   TUSPageProducer = class(TPageProducer)
  13.   private
  14.     FOnScriptingBlock: TUSScriptingBlockEvent;
  15.   protected
  16.     function DoScriptBlock(aBody: string): string;
  17.   public
  18.     function ContentFromStream(Stream: TStream): string; override;
  19.   published
  20.     property OnScriptingBlock: TUSScriptingBlockEvent read FOnScriptingBlock write FOnScriptingBlock;
  21.     { Event fires when a block delimited by <% %> is found. }
  22.   end;
  23.  
  24. procedure Register;
  25.  
  26. implementation
  27.  
  28. uses
  29.   CopyPrsr;
  30.  
  31. procedure Register;
  32. begin
  33.   RegisterComponents('Internet', [TUSPageProducer]);
  34. end;
  35.  
  36. { TUSPageProducer }
  37.  
  38. function TUSPageProducer.ContentFromStream(Stream: TStream): string;
  39. var
  40.   Parser: TCopyParser;
  41.   OutStream: TStringStream;
  42.   ParamStr, ReplaceStr, TokenStr: string;
  43.   ParamList: TStringList;
  44.   LeadingTagChar: Char;
  45.   TrailingTagChar: Char;
  46.  
  47.   function ExtractScriptBody: string;
  48.   begin
  49.     with Parser do
  50.     begin
  51.       Result := SkipToken(False);
  52.       while Token <> toEOF do
  53.       begin
  54.         Result := Result + SkipToToken('%');
  55.         SkipToken(False);
  56.         if Token = '>' then
  57.           Break
  58.         else
  59.           Result := Result + TokenString;
  60.       end;
  61.     end;
  62.   end;
  63. begin
  64.   LeadingTagChar := '<';
  65.   TrailingTagChar := '>';
  66.  
  67.   OutStream := TStringStream.Create('');
  68.   try
  69.     Parser := TCopyParser.Create(Stream, OutStream);
  70.     with Parser do
  71.     try
  72.       while True do
  73.       begin
  74.         while not (Token in [toEof, LeadingTagChar]) do
  75.         begin
  76.           CopyTokenToOutput;
  77.           SkipToken(True);
  78.         end;
  79.         if Token = toEOF then Break;
  80.         if Token = LeadingTagChar then
  81.         begin
  82.           case SkipToken(False) of
  83.             '#': { preserve support for original TPageProducer }
  84.               begin
  85.                 SkipToken(False);
  86.                 TokenStr := TokenString;
  87.                 ParamStr := TrimLeft(TrimRight(SkipToToken(TrailingTagChar)));
  88.                 ParamList := TStringList.Create;
  89.                 try
  90.                   ExtractHTTPFields([' '], [' '], PChar(ParamStr), ParamList);
  91.                   ReplaceStr := HandleTag(TokenStr, ParamList);
  92.                   OutStream.WriteString(ReplaceStr);
  93.                 finally
  94.                   ParamList.Free;
  95.                 end;
  96.                 SkipToken(True);
  97.               end;
  98.             '%':  { new support for <% %> tokens }
  99.               begin
  100.                 ReplaceStr := DoScriptBlock(ExtractScriptBody);
  101.                 OutStream.WriteString(ReplaceStr);
  102.                 SkipToken(True);
  103.               end;
  104.             else
  105.             begin
  106.               OutStream.WriteString(LeadingTagChar);
  107.               Parser.CopyTokenToOutput;
  108.               Parser.SkipToken(True);
  109.             end;
  110.           end;
  111.         end;
  112.       end;
  113.     finally
  114.       Parser.Free;
  115.     end;
  116.     Result := OutStream.DataString;
  117.   finally
  118.     OutStream.Free;
  119.   end;
  120. end;
  121.  
  122. function TUSPageProducer.DoScriptBlock(aBody: string): string;
  123. begin
  124.   Result := aBody;
  125.   if Assigned(FOnScriptingBlock) then
  126.     FOnScriptingBlock(Self, aBody, Result);
  127. end;
  128.  
  129. end.
  130.  
  131.